home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / comp0_89.lha / Feel / Boot / CBoot / character.em < prev    next >
Lisp/Scheme  |  1993-07-04  |  2KB  |  72 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: character.em
  4. ;; Date: Wed Jun 30 12:32:03 1993
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;
  9.  
  10. (defmodule character
  11.   (init 
  12.    extras0
  13.    gens
  14.    defs
  15.    macros0
  16.    table
  17.    characters
  18.    )
  19.   ()
  20.  
  21.   (deflocal lc-chars "abcdefghijklmnopqrstuvwxyz")
  22.   (deflocal uc-chars "ABCDEFGHIJKLMNOPQRSTUVWXYZ")
  23.  
  24.   (deflocal to-lower (make <table> 'comparator eql 'hash-function generic-hash))
  25.   (deflocal to-upper (make <table> 'comparator eql 'hash-function generic-hash))
  26.   
  27.   (export characterp)
  28.  
  29.   (labels
  30.    ((loop (i table from to)
  31.       (if (< i 0)
  32.           ()
  33.         (progn
  34.           ((setter table-ref) table (string-ref from i) (string-ref to i))
  35.           (loop (- i 1) table from to)))))
  36.    (loop (- (string-length uc-chars) 1) to-lower uc-chars lc-chars)
  37.    (loop (- (string-length lc-chars) 1) to-upper lc-chars uc-chars))
  38.  
  39.   (defgeneric as-lowercase (x))
  40.  
  41.   (export as-lowercase)
  42.  
  43.   (defmethod as-lowercase ((c <character>)) (or (table-ref to-lower c) c))
  44.  
  45.   (defgeneric as-uppercase (x))
  46.  
  47.   (export as-uppercase)
  48.  
  49.   (defmethod as-uppercase ((c <character>)) (or (table-ref to-upper c) c))
  50.  
  51.   (defmethod = ((c1 <character>) (c2 <character>))
  52.     (equal c1 c2))
  53.  
  54.   (defun upperp (c) (member c uc-chars))
  55.  
  56.   (defun lowerp (c) (member c lc-chars))
  57.  
  58.   (defun digitp (c) (member c "0123456789"))
  59.  
  60.   (defmethod binary< ((c1 <character>) (c2 <character>))
  61.     (cond
  62.      ((and (upperp c1) (upperp c2))
  63.       (< (character-to-integer c1) (character-to-integer c2)))
  64.      ((and (lowerp c1) (lowerp c2))
  65.       (< (character-to-integer c1) (character-to-integer c2)))
  66.      ((and (digitp c1) (digitp c2))
  67.       (< (character-to-integer c1) (character-to-integer c2)))
  68.      (t ())))
  69.  
  70.   ;; end module
  71.   )
  72.